Developer CD Series 1992 June: ROMin Holiday/ADC Developer CD (1992-06) (''ROMin Holiday'')_iso/Developer Connection - 06-1992.iso/Development Platforms/LISP Related/Generalized LISP/Glisp 1.2/Mlisp dialect/Mlisp.glisp

Text File | 1990-08-19 | 13.2 KB | 496 lines | [TEXT/CCL ]

~---------------------------------------------------------------------------------------~
~                Rules for Mlisp (Meta Lisp)                ~
~---------------------------------------------------------------------------------------~

-define language Mlisp-


-Lisp-

`(export '(mlispProgram mlispFunction reparseMlisp) :glisp)


-Plisp-

glispLanguage (add rule) =
    ~ add the Mlisp dialect to "Generalized Lisp"

    '-  Mlisp  '-  <mlispProgram>:p  ->  :p;


mlispProgram =
    ~ an Mlisp program is a sequence of expressions each terminated by a semicolon

    <sourceLanguage Mlisp>  [ <expression>:e  ';  <flush> ]*  ->  :e;


expression =
    ~ an expression is one or more basic expressions separated by the word "also".
    ~ this clumps multiple expressions into one (progn ...) expression.

    [ <precedence 0 <basicExpression>>:e / also ]+  ->  <makeProgn :e>;


basicExpression =
    ~ basic expressions are where most of the syntax in Mlisp appears

    begin  <blockDeclarations>:d  <expressions ';>:e  end  ->
        (prog :d ::e),

    if  <expression>:p  then  <condClause :p>:c1  ->
        (cond :c1),

    if  <expression>:p  then  <condClause :p>:c1  else  <condClause t>:c2  ->
        (cond :c1 :c2),

    if  <expression>:p  then  <condClause :p>:c1  else  <condClause t>
            ('t ('cond ...))  ->
        (cond :c1 ...),

    return  <expression>:e  ->
        (return :e),

    do  <expression>:e  [until | while]  <expression>:p  ->
        (do (&v)
            (nil)
            (setq &v :e)
            (cond ([:p | (not :p)] (return &v)))),

    collect  <expression>:e  [until | while]  <expression>:p  ->
        (do (&v)
            (nil)
            (setq &v (<collectFunction :e> &v :e))
            (cond ([:p | (not :p)] (return &v)))),

    until  <expression>:p  [do | collect]  <expression>:e  ->
        (do (&v)
            (:p (return &v))
            (setq &v [:e | (<collectFunction :e> &v :e)])),

    while  <expression>:p  [do | collect]  <expression>:e  ->
        (do (&v)
            ((not :p) (return &v))
            (setq &v [:e | (<collectFunction :e> &v :e)])),

    for  <forClauses for>:fl  [do | collect]  <expression>:e
            [ until <expression>:p | while <expression>:p | ]  ->
        <translateFor :fl  [prog2 | <collectFunction :e>]  :e
            [:p | (not :p) | nil] >,

    lambda  <lambdaBody lambda>:lam  [ ';  '\(  <arguments>:args  ') ]  ->
        [(:lam ::args) | :lam],

    let    <lambdaBody let>:l    ->  :l,

    let\*  <lambdaBody let\*>:l    ->  :l,

    defun  <nonReservedWord>:name  <checkFunction :name>  <lambdaBody lambda>
            (lambda ...)  ->
        (defun :name ...),

    defmacro  <nonReservedWord>:name  <checkFunction :name>  <lambdaBody lambda>
            (lambda ...)  ->
        (defmacro :name ...),

    defobfun  <nonReservedWord>:name  '\(  <identifier>:obj  ')
            <checkFunction (:name :obj)>  <lambdaBody lambda> (lambda ...) ->
        (defobfun (:name :obj) ...),

    case  <caseBody case>:c            ->  :c,

    ccase  <caseBody ccase>:c        ->  :c,

    ecase  <caseBody ecase>:c        ->  :c,

    typecase  <caseBody typecase>:c        ->  :c,

    ctypecase  <caseBody ctypecase>:c    ->  :c,

    etypecase  <caseBody etypecase>:c    ->  :c,

    global  <globalVariables>:vars        ->  :vars,

    constant  <aConstant>:const        ->  :const,

~    define ...,

    ~ generic expressions, e.g. null foo(x,y,z).bar
    <prefixes>:p  <primitive>  <qualifiers>:q  ->  <composition :p :q>;


primitive =
    <nonReservedWord>        ->  ,            ~ x

    ''  :sexp            ->  (quote :sexp),    ~ '(a b c)

    '\(  <expression>:e  ')        ->  :e,            ~ (x := y + z)

    '{  <expressions ',>:e  '}    ->  (list ::e),        ~ {x, y, z}

    ':  <identifier>:id  <pVariable :id t>:var
                    ->  (vEval :var),    ~ :x

    :x  {if not symbolp(:x) :failMessage "anything but a symbol"}
                    ->  :x;            ~ all other data types


qualifiers =
    :x  ->  :x,                        ~ x

    :x  '\(  <arguments>:args  ')  ->            ~ foo(x, y, z)
        <qualifiers (:x ::args) >,

    :x  '[  <expressions ',>:args  ']  ->            ~ foo[x, y, z]
        <qualifiers <translateIndex :x :args>>,

    :x  '.  [<identifier> | <primitive>]  :y  ->        ~ x.y  or  x.(y)
        <qualifiers (get :x [(quote :y) | :y]) >,

    :x  ':=  <simpleExpression>:e  ->            ~ x := y, x(y) := z,
        (setf :x :e);                    ~ x[y] := z, or x.y := z


simpleExpression =
    ~ a simple expression is the same as an expression except that it doesn't allow
    ~ "also" to be included.  By convention in Mlisp, a <simpleExpression> always
    ~ occurs on the right of the assignment operator (:=).

    <precedence 0 <basicExpression>>  ->  ;


blockDeclarations =
    [ <blockDeclaration>:d  '; ]*  ->  ( [::d]* );


blockDeclaration =
    new  <variables nil>:vars  ->  :vars;


lambdaBody =
    :lam  '\(  <variables t>:vars  ')  '=  <expression>:e  ->
        (:lam :vars :e),

    :lam  '\(  <variables t>:vars  ')  '=  <expression>('progn ...)  ->
        (:lam :vars ...);


condClause =
    :p  <expression>:e        ->  (:p :e),

    :p  <expression>('progn ...)    ->  (:p ...);


forClauses =
    [ <forClause>:f ]*  ->  :f;


forClause =
    for  <nonReservedWord>:var  [in | on]  <expression>:e  ->
        (:var  [in | on]  :e),

    for  <nonReservedWord>:var  ':=  <simpleExpression>:from
            to  <expression>:to  [by  <expression>:by]  ->
        (:var  ':=  :from  :to  [:by | 1]);


translateFor =
    :clauses  :fn  :ex  ['nil | :be]=:b  ->
        (do ( [<forVariable :clauses>]*  &v )
            ( <forStopTest (or [<forStop :clauses>]*)>  &v )
            [<setForVariable :clauses>]*
            <setForValue :ex :fn>
            [ | (if :be (return &v)) ]=:b );


forVariable =
    (:var  in  :e)            ->  {do :var2 := intern("&" cat :var cat "&")}
                        :var  (:var2 :e (cdr :var2)),

    (:var  on  :e)            ->  (:var :e (cdr :var)),

    (:var  ':=  :min  :max  :step)    ->  <<numericForVariable :var :min :max :step>>;


forStop =
    (:var  in  :e)            ->  (atom {value intern("&" cat :var cat "&")}),

    (:var  on  :e)            ->  (atom :var),

    (:var  ':=  :min  :max  :step)    ->  <<numericForStopTest :var :max :step>>;


forStopTest =
    ('or :test)    ->  :test,    ~ optimization for single tests

    :test        ->  :test;


setForVariable =
    (:var  in  :e)    ->  (setq :var (car {value intern("&" cat :var cat "&")})),

    :clause        ->  ;


setForValue =
    :e  :fn        ->  (setq &v (:fn &v :e)),

    :e  'prog2    ->  (setq &v :e),

    'nil :fn    ->  ;


collectFunction =
    ('list ...)    ->  nconc,

    :ex        ->  append;


caseBody =
    :case  <expression>:e  of  begin  [ <caseClause>:c  '; ]*  end  ->
        (:case :e ::c);


caseClause =
    :key  ':  <expression>:e        ->  (:key :e),

    :key  ':  <expression>('progn ...)    ->  (:key ...);


globalVariables =
    <nonReservedWord>:var  [':=  <simpleExpression>:e]  [',]  ->
        (proclaim (quote (special :var)))  [';  (setq :var :e)]  [';  global];


variables =
    't    [ [<modifier>]  <aVariable>:vars / ', ]*    ->  :vars,

    'nil  [ <aVariable>:vars / ', ]*        ->  :vars;


modifier =
    ~ system keywords such as &optional and &rest are allowed only in the formal
    ~ variable lists of function definitions and lambdas

    :word  {if member(:word, `lambda-list-keywords, :test `#'eq)}  ->  :word  ', ;


aVariable =
    <nonReservedWord>:v                ->  :v,        ~ x

    <nonReservedWord>:v  ':=  <simpleExpression>:e    ->  (:v :e),    ~ x := y

    <aKeyword>:key  <nonReservedWord>:v        ->  (:key :v),    ~ :key x

    <aKeyword>:key  <nonReservedWord>:v  ':=            ~ :key x := y
        <simpleExpression>:e            ->  ((:key :v) :e);


aKeyword =
    ':  <identifier>:id  ->  <makeKeyword :id>;


expressions =
    ';  [ <expression>:e  '; ]*    ->  :e,

    ',  [ <expression>:e / ', ]*    ->  :e;


arguments =
    ~ translates the arguments to a function call; e.g. foo(x, y, :pretty t).
    ~ it is not intended to be used for any other purpose

    [ <argument>:a / ', ]*  ->  :a;


argument =
    ~ handles keyword/argument pairs in function calls, e.g. foo(a, b, :pretty t)

    ':  <identifier>:key  <expression>:e  {if peek() member '(\, \))}  ->
        <makeKeyword :key>  ',  :e,

    <expression>:e  ->  :e;


aConstant =
    <nonReservedWord>:id  ':=  <simpleExpression>:e  [',]  ->
        (defconstant :id :e)  [';  constant];


braceExpression =
    ~ when Mlisp is loaded, allow Mlisp expressions in addition to Lisp expressions
    ~ inside of Plisp braces { }; e.g allow either
    ~    {do `(< x y)}     or     {do x < y}

    <sourceLanguage Mlisp>  <expression>:e  <sourceLanguage Plisp>  ->  :e;


mlispFunction =
    ~ for use by 'reparse'

    <sourceLanguage Mlisp>  <expression>:e  ';  ->  :e;


~---------------------------------------------------------------------------------------~
~                A few support routines                    ~
~---------------------------------------------------------------------------------------~

-Mlisp-

defun prefixes (&aux token := peek()) =
    ~ checks if the next input token is an Mlisp prefix function (a one-argument
    ~ function having the property glisp::prefix).
    ~ such functions may be used without parentheses around their argument.

    if symbolp(token) and token.prefix then    ~ it's a prefix
        next() also            ~ skip over it
        if peek() eq !lparen then    ~ put it back; call has parens: fn(arg)
            !source := {token} xPrepend !source also
            nil
        else token cons prefixes()    ~ check for more prefixes
    else nil;


defun precedence (rbp, e, &aux op := peek()) =
    ~ this is where the precedence of infix operators controls the parse.
    ~ operator precedence is determined by their left and right "binding powers".
    ~ an operator with a higher right binding power has precedence over an operator
    ~ with a lower left binding power.  All binding powers are > 0.
    ~ 'op' is the next infix operator, if any, in the input.

    if not symbolp(op) then            ~ make sure it's a symbol
        failure("a symbol")
    else if rbp > bindingPower(op,'left) then  ~ stronger right binding power
        e                ~ e.g.  a * b + c  (where op is +)
    else next() also            ~ stronger left binding power
        precedence(rbp, compose(op, e,    ~ e.g.  a + b * c  (where op is *)
            precedence(bindingPower(op,'right), pcall('basicExpression, nil))));


defun bindingPower (op, ind) =
    ~ computes the binding power of infix operators

    op.(ind)                ~ operator has the specified indicator
        or (op.mlisp and -1)        ~ or is an Mlisp reserved word
        or (op.delimiter and -1)    ~ or is a delimiter
        or 'default.(ind);        ~ otherwise use the default value


defun compose (fn, e1, e2) =
    ~ :fn  {if :fn.associative}  (:fn ...)  (:fn ...)    ->  (:fn ... ...)
    ~ :fn  {if :fn.associative}  (:fn ...)  :e2        ->  (:fn ... :e2)
    ~ :fn  {if :fn.associative}  :e1  (:fn ...)        ->  (:fn :e1 ...)
    ~ :fn  :e1  :e2                        ->  (:fn :e1 :e2)

    if not fn.associative then {fn, e1, e2}
    else if consp(e1) and car(e1) eq fn then
        if consp(e2) and car(e2) eq fn then e1 append cdr(e2)
        else e1 append {e2}
    else if consp(e2) and car(e2) eq fn then fn cons e1 cons cdr(e2)
    else {fn, e1, e2};


defun composition (fns, ex) =
    ~ (f g ...) x -> (f (g (... x)))

    if null fns then ex
    else {car fns, composition(cdr fns, ex)};


defun makeKeyword (id) =
    ~ makes id a keyword in the Keyword package

    intern(`symbol-name(id), 'keyword);


defun makeProgn (l) =
    ~ translates a list of expressions (e1 e2 ...) -> (progn e1 e2 ...)
    ~ and a single expression (e1) -> e1

    if null cdr(l) then car(l)
    else 'progn cons l;


defun translateIndex (ex, l) =
    ~ translates x[n] -> (nth (- n 1) x); optimizes when n is an explicit integer

    if null l then ex
    else if integerp(car(l)) then translateIndex(numericIndex(car l, ex), cdr l)
    else translateIndex({'nth, {'\-, car l, 1}, ex}, cdr l);


defun numericIndex (n, ex) =
    if n < 1 then ex
    else if n > 10 then {'nth, n-1, ex}
    else {'(car cadr caddr cadddr fifth sixth seventh eighth ninth tenth)[n], ex};


defun numericForVariable (var, min, max, step) =
    begin
    new max2  := if not numberp(max)  then intern("&"  cat var cat "&" ) else nil;
    new step2 := if not numberp(step) then intern("&&" cat var cat "&&") else nil;
    return    {{var, min, {'\+, var, step2 or step}}}
            append (max2  and {{max2,  max }})
            append (step2 and {{step2, step}});
    end;


defun numericForStopTest (var, max, step) =
    begin
    if not numberp(max)  then max  := intern("&"  cat var cat "&" );
    if not numberp(step) then step := intern("&&" cat var cat "&&");
    return    if not numberp(step) then
            { {'and, {'\>, step, 0}, {'\>, var, max}},
              {'and, {'\<, step, 0}, {'\<, var, max}},
              {'and, {'\=, step, 0},
                    '(error "increment = 0 in Mlisp FOR loop")} }
        else if step > 0 then {{'\>, var, max}}
        else if step < 0 then {{'\<, var, max}}
        else pError("increment = 0 in FOR loop");
    end;


defun reparseMlisp (name, filename, &key target := nil, package := nil) =
    ~ supplies the proper arguments to 'reparse' for parsing an Mlisp function

    reparse(name, filename, :source 'Mlisp, :target target,
        :parser 'mlispFunction, :locater 'locateMlispFunction,
        :readtable `*glisp-readtable*, :package package);


defun locateMlispFunction (name, stream, `*readtable*) =
    ~ quickly skips to the beginning of an Mlisp function; works only on file streams

    begin
    new x := '\;, index, foundit;
    until (x eq '\; or x eq '\- or x eq !eof)
        and case x of
            begin
            \; :                ~ ; defun name ...
                begin
                index := `file-position(stream);
                foundit :=  read(stream, nil, !eof, nil) member
                        '(defun defmacro defobfun)
                    and read(stream, nil, !eof, nil) eq name;
                `file-position(stream, index);
                return foundit;
                end;
            \- :                ~ -Mlisp- name = ...
                begin
                index := `file-position(stream);
                foundit :=  read(stream, nil, !eof, nil) eq 'Mlisp
                    and read(stream, nil, !eof, nil) eq '\-
                    and (index := `file-position(stream))
                    and read(stream, nil, !eof, nil) member
                        '(defun defmacro defobfun)
                    and read(stream, nil, !eof, nil) eq name;
                `file-position(stream, index);
                return foundit;
                end;
            otherwise:            ~ end of file
                t;
            end
    do x := read(stream, nil, !eof, nil);
    return x neq !eof;
    end;